home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / pnl004.zip / PROFILER.PAS < prev    next >
Pascal/Delphi Source File  |  1990-05-19  |  18KB  |  507 lines
  1. program profiler;
  2.  
  3. (* (c) Jan-Erik Rosinowski 1989 *)
  4.  
  5. {$A+,B-,D+,E+,F-,I+,L+,N-,O-,R-,S+,V-}
  6. {$M 16384,0,655360}
  7.  
  8. uses
  9.   crt;
  10.  
  11. const
  12.   stacksize        = 50;
  13.   prounitname      = 'Profile';
  14.   probegin         = '.PBegin(';
  15.   proend           = '.PEnd';
  16.   prospec          = '.SpecFile(';
  17.   tempfileextension= '.PR$';
  18.   profileextension = '.PRF';
  19.   initidentifier   = '(INIT)';
  20.  
  21. type
  22.   string20         = string[20];
  23.   string30         = string[30];
  24.   proctypes        = (_program,_unit,_function,_procedure,skipit);
  25.   stacktype        = array[0..stacksize] of record
  26.                                               procname : string30;
  27.                                               procnr   : word;
  28.                                               proctype : proctypes;
  29.                                               written  : boolean;
  30.                                             end;
  31.   listelementptr   = ^listelementtype;
  32.   listelementtype  = record
  33.                        name     : string30;
  34.                        next     : listelementptr;
  35.                      end;
  36.  
  37. var
  38.   stack            : stacktype;        (* storage for proc's and func's *)
  39.   stackptr         : word;
  40.   proccntr         : word;             (* non-recursive count of proc
  41.                                           headers seen *)
  42.   beginlevel       : word;             (* begin inc's, end dec's *)
  43.   recordlevel      : word;             (* record inc's, case:-, end dec's *)
  44.   handledmodules   : listelementptr;   (* list of modules yet seen *)
  45.   showhelp         : boolean;
  46.   error            : boolean;          (* error ocurred while 'precompiling' *)
  47.   main             : string20;         (* name of main module *)
  48.   scanmsgline      : word;             (* row of message text *)
  49.   tempfile         : text;             (* .PR$ - file *)
  50.   nameoftempfile   : string;           (* it's name *)
  51.   q                : word;             (* don't bother *)
  52.  
  53. function upcasestr(s:string):string;
  54. var
  55.   q                : word;
  56. begin
  57.   for q:=1 to length(s) do s[q]:=upcase(s[q]);
  58.   upcasestr:=s;
  59. end;
  60.  
  61. function fixname(s:string20):string20;
  62. begin
  63.   if pos('.',s)=0 then s:=s+'.PAS';
  64.   fixname:=upcasestr(s);
  65. end;
  66.  
  67. procedure includeinlist(var ptr:listelementptr; name:string20);
  68. var
  69.   temp             : listelementptr;
  70. begin
  71.   new(temp);
  72.   temp^.next:=ptr; temp^.name:=fixname(name);
  73.   ptr:=temp;
  74. end;
  75.  
  76. function inlist(ptr:listelementptr; name:string20):boolean;
  77. begin
  78.   name:=fixname(name);
  79.   while (ptr<>nil) and (ptr^.name<>name) do ptr:=ptr^.next;
  80.   inlist:=ptr<>nil;
  81. end;
  82.  
  83. function prep_module(path:string; nameofprg:string20):boolean;
  84. const
  85.   maxkeywords      = 19;
  86.   keyword          : array[1..maxkeywords+1] of string30 =
  87.                      ('PROGRAM','UNIT','USES','INTERFACE','IMPLEMENTATION',
  88.                       'PROCEDURE','FUNCTION','BEGIN','END',
  89.                       'RECORD','CASE','EXTERNAL','INLINE','INTERRUPT',
  90.                       'CONST','TYPE','VAR','FORWARD','EXIT','');
  91.  
  92. var
  93.   source           : text;             (* source-file *)
  94.   inputbuffer      : pointer;          (* buffer for source-file *)
  95.   destination      : text;             (* destination-file *)
  96.   bakname          : string20;         (* new name of original file *)
  97.   symbol           : string;           (* words as UNIT,BEGIN,... *)
  98.   upcasedsymbol    : string;           (* ..upcased *)
  99.   kw               : word;             (* symbols' token *)
  100.   usesrequired     : boolean;          (* include of USES required *)
  101.   nextidentifier   : proctypes;        (* put next symbol on stack *)
  102.   interfacemode    : boolean;          (* don't care about PROCEDURE,
  103.                                           FUNCTION,..*)
  104.   pending          : char;             (* read but not yet handled char *)
  105.   error            : boolean;          (* error flag *)
  106.  
  107. procedure getsymbol(var symbol:string);
  108. const
  109.   alphanum         = ['A'..'Z','a'..'z','0'..'9','_'];
  110. var
  111.   ch               : char;             (* buffer for last read char *)
  112.   lastch           : char;             (* buffer for char read previous to
  113.                                           ch *)
  114.   intext           : boolean;          (* we're scanning text-constant *)
  115.   again            : boolean;          (* so far only shit, repeat it *)
  116.   directive        : boolean;          (* compiler directive recognised *)
  117.  
  118. procedure handledirective;
  119. var
  120.   s                : string30;
  121.  
  122. function getoption(s:string30):string30;
  123. var
  124.   q,w              : word;
  125. begin
  126.   q:=1;
  127.   while s[q]=' ' do inc(q);
  128.   w:=length(s);
  129.   while s[w]=' ' do dec(w);
  130.   getoption:=copy(s,q,w-q+1);
  131. end;
  132.  
  133. begin
  134.   write(destination,symbol);
  135.   s:=upcasestr(copy(symbol,3+ord(symbol[1]='('),
  136.                  length(symbol)-3-2*ord(symbol[1]='(')));
  137.   if copy(s,1,2)='I ' then error:=not prep_module(path+'/'+nameofprg,
  138.                                         getoption(copy(s,3,length(s)-2)));
  139.   if not error then again:=true;
  140. end;
  141.  
  142. begin
  143.   repeat
  144.     directive:=false;
  145.     again:=false;
  146.     ch:=pending;
  147.     if ch=#0 then read(source,ch);
  148.     while not eof(source) and ((ch=' ') or (ch=#13) or (ch=#10) or (ch=#0)) do
  149.       begin
  150.         if ch<>#0 then write(destination,ch);
  151.         read(source,ch);
  152.       end;
  153.     symbol:='';
  154.     if (ch='(') or (ch='{') or (ch='''') then
  155.       begin
  156.         lastch:=ch;
  157.         read(source,ch);
  158.         symbol:=lastch+ch;
  159.         if (lastch='{') or (symbol='(*') or (lastch='''') then
  160.           begin              (* comment/directive/textconstant *)
  161.             if (lastch='{') or (lastch='''') then
  162.               directive:=symbol='{$'
  163.             else
  164.               begin
  165.                 read(source,ch);
  166.                 symbol:=symbol+ch;
  167.                 directive:=symbol='(*$';
  168.               end;
  169.             if not directive then write(destination,symbol);
  170.             if (symbol<>'{}') and (symbol<>'''''') then
  171.               repeat
  172.                 lastch:=ch;
  173.                 read(source,ch);
  174.                 if directive then symbol:=symbol+ch
  175.                 else write(destination,ch);
  176.               until ((symbol[1]='{') and (ch='}'))
  177.                  or ((symbol[1]='(') and (lastch+ch='*)'))
  178.                  or ((symbol[1]='''') and (ch=''''));
  179.             pending:=#0;
  180.             again:=not directive;
  181.           end
  182.         else
  183.           begin
  184.             write(destination,lastch);
  185.             pending:=ch;
  186.             nextidentifier:=skipit;
  187.             again:=true;
  188.           end;
  189.       end
  190.     else
  191.       if ch in alphanum then
  192.         begin                  (* identifier or so *)
  193.           repeat
  194.             symbol:=symbol+ch;
  195.             read(source,ch);
  196.           until eof(source) or not (ch in alphanum);
  197.           pending:=ch;
  198.         end
  199.       else
  200.         begin
  201.           symbol:=ch;
  202.           pending:=#0;
  203.         end;
  204.     if directive then handledirective;
  205.   until not again;
  206. end;
  207.  
  208. procedure checkusesrequired;           (* check whether to include USES
  209.                                           profilerunit *)
  210. begin
  211.   if usesrequired then
  212.     begin
  213.       writeln(destination,'USES ',prounitname,';');
  214.       usesrequired:=false;
  215.     end;
  216. end;
  217.  
  218. procedure scanmsg(s:string);           (* for your eyes only *)
  219. begin
  220.   if scanmsgline=0 then scanmsgline:=wherey;
  221.   gotoxy(1,scanmsgline);
  222.   write('Scanning ',s);
  223.   if s='' then write('finished.',' ':15) else write(' ':15);
  224. end;
  225.  
  226. procedure maketempfile;
  227. var
  228.   s                : string;
  229.   q                : word;
  230. begin
  231.   with stack[stackptr] do
  232.     if (stackptr>0) and not written then
  233.       begin
  234.         write(tempfile,procnr:4,' ');
  235.         case proctype of
  236.           _program   : write(tempfile,'Prog ');
  237.           _unit      : write(tempfile,'Unit ');
  238.           _procedure : write(tempfile,'Proc ');
  239.           _function  : write(tempfile,'Func ');
  240.           end;
  241.         q:=stackptr+1; s:='';
  242.         repeat
  243.           dec(q);
  244.           s:=stack[q].procname+'.'+s;
  245.         until (stack[q].proctype=_unit) or (q<=2);
  246.         s[0]:=chr(pred(length(s)));
  247.         if stack[stackptr].proctype=_unit then s:=s+initidentifier;
  248.         writeln(tempfile,s,' ':50-length(s));
  249.         written:=true;
  250.       end;
  251. end;
  252.  
  253. begin
  254.   usesrequired:=path='';  (* there might be no PROGRAM-Identifier *)
  255.   error:=false;
  256.   interfacemode:=false;
  257.   pending:=#0;
  258.   nextidentifier:=skipit;
  259.   nameofprg:=upcasestr(nameofprg);
  260.   if not inlist(handledmodules,nameofprg) then
  261.     begin
  262.       nameofprg:=fixname(nameofprg);
  263.       includeinlist(handledmodules,nameofprg);
  264.       bakname:=nameofprg;
  265.       bakname[length(bakname)]:=nameofprg[length(nameofprg)-2];
  266.       bakname[length(bakname)-2]:=nameofprg[length(nameofprg)];
  267.       assign(source,nameofprg);
  268.       assign(destination,nameofprg);
  269.       (*$i-*)
  270.       rename(source,bakname);
  271.       (*$i+*)
  272.       if ioresult<>0 then
  273.         begin
  274.          writeln;
  275.          writeln('(',nameofprg,') not found or failed renaming.');
  276.          error:=path='';
  277.         end
  278.       else
  279.         begin
  280.           reset(source);
  281.           rewrite(destination);
  282.           scanmsg(path+'/'+nameofprg);
  283.           while not (eof(source) or error) do
  284.             begin
  285.               getsymbol(symbol);
  286.               if nextidentifier<>skipit then
  287.                 begin
  288.                   write(destination,symbol);
  289.                   maketempfile;
  290.                   inc(proccntr); inc(stackptr);
  291.                   with stack[stackptr] do
  292.                     begin
  293.                       procname:=symbol; procnr:=proccntr;
  294.                       proctype:=nextidentifier; written:=false;
  295.                     end;
  296.                   nextidentifier:=skipit;
  297.                 end
  298.               else
  299.                 begin
  300.                   upcasedsymbol:=upcasestr(symbol);
  301.                   keyword[maxkeywords+1]:=upcasedsymbol;
  302.                   kw:=1;
  303.                   while upcasedsymbol<>keyword[kw] do inc(kw);
  304.                   case kw of
  305.                     maxkeywords+1 :            (* irrelevant word *)
  306.                            write(destination,symbol);
  307.  
  308.                     8     :                    (* begin *)
  309.                            begin
  310.                              checkusesrequired;
  311.                              inc(beginlevel);
  312.                              write(destination,symbol);
  313.                              if beginlevel=1 then
  314.                                begin
  315.                                  if stack[stackptr].procnr<2 then
  316.                                    write(destination,' ',prounitname,prospec,
  317.                                      '''',nameoftempfile,'''',',','''',
  318.                                      profileextension,'''',');');
  319.                                  write(destination,' ',prounitname,probegin,
  320.                                    stack[stackptr].procnr,');');
  321.                                end;
  322.                            end;
  323.  
  324.                     9     :                    (* end *)
  325.                            begin
  326.                              if recordlevel>0 then
  327.                                dec(recordlevel)
  328.                              else
  329.                                if beginlevel>0 then
  330.                                  begin
  331.                                    dec(beginlevel);
  332.                                    if beginlevel=0 then
  333.                                      begin
  334.                                        maketempfile;
  335.                                        write(destination,';',prounitname,
  336.                                          proend,';');
  337.                                        dec(stackptr);
  338.                                      end;
  339.                                  end
  340.                                else
  341.                                  dec(stackptr);  (* units without startcode *)
  342.                              write(destination,symbol);
  343.                            end;
  344.  
  345.                     6,7   :                    (* function, procedure *)
  346.                            begin
  347.                              checkusesrequired;
  348.                              write(destination,symbol);
  349.                              if not interfacemode then
  350.                                if kw=6 then nextidentifier:=_procedure
  351.                                else nextidentifier:=_function;
  352.                            end;
  353.  
  354.                     15,16,                     (* const, var, type *)
  355.                     17    :begin
  356.                              checkusesrequired;
  357.                              write(destination,symbol);
  358.                            end;
  359.  
  360.                     10    :                    (* record *)
  361.                            begin
  362.                              inc(recordlevel);
  363.                              write(destination,symbol);
  364.                            end;
  365.  
  366.                     11    :                    (* case *)
  367.                            begin
  368.                              if recordlevel=0 then inc(beginlevel);
  369.                              write(destination,symbol);
  370.                            end;
  371.  
  372.                     12,14,                     (* external, interrupt, *)
  373.                     18,13 :                    (* forward, inline *)
  374.                            begin
  375.                              write(destination,symbol);
  376.                              if not interfacemode
  377.                                 and ((kw<>13) or (beginlevel=0))
  378.                                 and not stack[stackptr].written then
  379.                                begin
  380.                                  dec(proccntr);
  381.                                  dec(stackptr);
  382.                                end;
  383.                            end;
  384.  
  385.                     19    :                    (* exit *)
  386.                            write(destination,'begin ',prounitname,proend,
  387.                              ';exit;end;');
  388.  
  389.                     1,2   :                    (* program, unit *)
  390.                            begin
  391.                              usesrequired:=true;
  392.                              if kw=1 then nextidentifier:=_program
  393.                              else nextidentifier:=_unit;
  394.                              write(destination,symbol);
  395.                            end;
  396.  
  397.                     3     :                    (* uses *)
  398.                            begin
  399.                              write(destination,symbol,' ');
  400.                              if usesrequired then
  401.                                write(destination,prounitname,',');
  402.                              usesrequired:=false;
  403.                              while (symbol<>';') and not error do
  404.                                begin
  405.                                  repeat
  406.                                    getsymbol(symbol);
  407.                                    write(destination,symbol);
  408.                                  until symbol<>',';
  409.                                  if symbol<>';' then
  410.                                    if symbol=prounitname then
  411.                                      begin
  412.                                        error:=true;
  413.                                        writeln;
  414.                                        writeln('Program already prepared!',#7);
  415.                                      end
  416.                                    else
  417.                                      error:=not prep_module(path+'/'+nameofprg,
  418.                                                   symbol);
  419.                                end;
  420.                            end;
  421.  
  422.                     4     :                    (* interface *)
  423.                            begin
  424.                              interfacemode:=true;
  425.                              write(destination,symbol);
  426.                            end;
  427.  
  428.                     5     :                    (* implementation *)
  429.                            begin
  430.                              interfacemode:=false;
  431.                              checkusesrequired;
  432.                              write(destination,symbol);
  433.                            end;
  434.  
  435.                   end;
  436.                 end;
  437.             end;
  438.           close(source);
  439.           if pending<>#0 then write(destination,pending);
  440.           write(destination,#26);
  441.           close(destination);
  442.         end;
  443.     end;
  444.   scanmsg(path);
  445.   prep_module:=not error;
  446. end;
  447.  
  448. begin
  449.   writeln;
  450.   writeln('Turbo-Profiler  v1.23   (c) Jan-Erik Rosinowski, 1989, 1990');
  451.   stackptr:=0;
  452.   proccntr:=0;
  453.   beginlevel:=0;
  454.   recordlevel:=0;
  455.   scanmsgline:=0;
  456.   handledmodules:=nil;
  457.   includeinlist(handledmodules,'SYSTEM');
  458.   includeinlist(handledmodules,'PRINTER');
  459.   includeinlist(handledmodules,'TURBO3');
  460.   includeinlist(handledmodules,'GRAPH');
  461.   includeinlist(handledmodules,'GRAPH3');
  462.   includeinlist(handledmodules,'DOS');
  463.   includeinlist(handledmodules,'CRT');
  464.   includeinlist(handledmodules,'OVERLAY');
  465.   if paramcount<1 then showhelp:=true
  466.   else
  467.     begin
  468.       showhelp:=false;
  469.       main:=paramstr(1);
  470.       if paramcount>1 then
  471.         begin
  472.           if copy(upcasestr(paramstr(2)),1,2)<>'/X' then showhelp:=true
  473.           else
  474.             for q:=3 to paramcount do
  475.               includeinlist(handledmodules,paramstr(q));
  476.         end;
  477.     end;
  478.   if showhelp then
  479.     begin
  480.       writeln;
  481.       writeln('PROFILER: Optimize your TURBO-Pascal-Programs !');
  482.       writeln('Usage   : PROFILER <Name of main module> [/X: ',
  483.                          '<Modules to exclude>]');
  484.       writeln('                                             ^ mind spaces!');
  485.       writeln;
  486.     end
  487.   else
  488.     begin
  489.       writeln;
  490.       nameoftempfile:=copy(fixname(main),1,
  491.                         length(fixname(main))-4)+tempfileextension;
  492.       assign(tempfile,nameoftempfile);
  493.       rewrite(tempfile);
  494.       error:=not prep_module('',main);
  495.       close(tempfile);
  496.       writeln;
  497.       if error then
  498.         begin
  499.           erase(tempfile);
  500.           writeln('PROFILER terminated due to error!',#7);
  501.         end
  502.       else
  503.         writeln('Program successfully transformed.');
  504.     end;
  505.   halt(ord(error or showhelp));
  506. end.
  507.